home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / basic / menumkr.zip / MM.BAS next >
BASIC Source File  |  1985-02-09  |  14KB  |  335 lines
  1. 10 ' MENU MAKER
  2. 20 ' by Andrew Fluegelman
  3. 30 ' Copyright (c) 1984 The Headlands Press, Inc.
  4. 40 ' May be reproduced in any medium for non-commercial use.
  5. 50 '
  6. 100 ' initialize
  7. 105 DEFINT A-Z:ON ERROR GOTO 9000
  8. 110 DEF FNLOCA(R,C)=160*R+2*C-162
  9. 115 DEF FNATTR(F,B)=-128*(F>15)+(F MOD 16)+(16*(B MOD 8))
  10. 120 DIM BK(4000) ' array for block karacters
  11. 125 DIM LIN1(160) ' array for line 1
  12. 130 R=1:C=1:FG=7:BG=0:I=0:J=0
  13. 135 DFG=7:DBG=0 ' default foreground & background colors
  14. 140 CR$=CHR$(13):BS$=CHR$(8):TB$=CHR$(9)
  15. 145 MARKED=0:MARK$="Z":CUT=0:CUT$="X":COPY$="C"
  16. 150 DELAY=10 '# ticks for delay
  17. 155 ASCIIVAL$=CHR$(0)
  18. 160 MMTEMP$="mmtemp.bin":MMHELP$="mmhelp.bin":INFIL$="mmsave.bin":SHOWFIL=0
  19. 165 DEF SEG=0:IF (PEEK(&H410) AND &H30)=&H30 THEN ADDRSEG=&HB000 ELSE ADDRSEG=&HB800
  20. 170 DEF SEG=ADDRSEG
  21. 200 ' startup
  22. 205 KEY OFF:FOR I=1 TO 10:KEY I, "":NEXT
  23. 210 COLOR DFG,DBG:SCREEN 0:WIDTH 80:CLS:LOCATE 1,1,0
  24. 215 PRINT TAB(15) "    * * * * * * MENU MAKER * * * * * *
  25. 220 PRINT TAB(15) "          by Andrew Fluegelman
  26. 225 PRINT
  27. 230 PRINT TAB(15) "Copyright (c) 1984 The Headlands Press, Inc.
  28. 235 PRINT:PRINT"  This program may be reproduced in any medium for non-commercial use.
  29. 240 GOSUB 8500:CLS
  30. 300 ' main loop
  31. 305 LOCATE R,C,1
  32. 310 K$=INKEY$: IF K$="" THEN 310
  33. 315 IF LEN(K$)>1 THEN GOSUB 500:GOTO 300
  34. 320 IF K$=CR$ THEN R=R+1:C=1:GOSUB 2000:GOTO 300
  35. 325 IF K$=BS$ THEN 455
  36. 330 IF K$=TB$ THEN C=C+5:GOSUB 2000:GOTO 300
  37. 335 GOSUB 400
  38. 340 GOTO 300
  39. 400 ' print k$
  40. 405 LOCA=FNLOCA(R,C):POKE LOCA,ASC(K$):POKE LOCA+1,FNATTR(FG,BG)
  41. 410 GOSUB 415:GOSUB 2000:RETURN
  42. 415 ' advance horizontally or vertically
  43. 420 IF VERT THEN R=R+1:RETURN ELSE C=C+1:RETURN
  44. 450 ' backspace
  45. 455 IF VERT THEN R=R-1 ELSE C=C-1
  46. 460 GOSUB 2000:K$=" ":GOSUB 400
  47. 465 IF VERT THEN R=R-1 ELSE C=C-1
  48. 470 GOSUB 2000:GOTO 300
  49. 500 ' extended keys
  50. 505 XK=ASC(MID$(K$,2,1))
  51. 510 IF XK>=16 AND XK <=50 THEN 700
  52. 515 IF (XK>=59 AND XK<=68) OR (XK>=84 AND XK<=113) THEN 800
  53. 520 IF (XK>=120 AND XK<=131) THEN 900
  54. 600 ' cursor control
  55. 605 IF XK=15 THEN C=C-5:GOSUB 2000:RETURN
  56. 610 IF XK=77 THEN C=C+1:GOSUB 2000:RETURN
  57. 615 IF XK=75 THEN C=C-1:GOSUB 2000:RETURN
  58. 620 IF XK=80 THEN R=R+1:GOSUB 2000:RETURN
  59. 625 IF XK=82 THEN GOSUB 8500:RETURN ' help
  60. 630 IF XK=72 THEN R=R-1:GOSUB 2000:RETURN
  61. 635 IF XK=71 THEN C=1:RETURN
  62. 640 IF XK=79 THEN C=80:RETURN
  63. 645 IF XK=115 THEN C=C-5:GOSUB 2000:RETURN
  64. 650 IF XK=116 THEN C=C+5:GOSUB 2000:RETURN
  65. 655 IF XK=119 THEN R=1:C=1:RETURN
  66. 660 IF XK=117 THEN R=25:C=1:RETURN
  67. 665 BEEP:RETURN
  68. 700 ' <alt>+alpha keys
  69. 702 IF XK=16 THEN GOSUB 8000:RETURN ' Quit
  70. 704 IF XK=17 THEN GOSUB 4200:RETURN ' Wipe screen clean
  71. 706 IF XK=20 THEN GOSUB 3200:RETURN ' Load a Text file
  72. 708 IF XK=22 THEN GOSUB 4900:RETURN ' Universal Foreground/Background
  73. 710 IF XK=23 THEN GOSUB 4400:RETURN ' Invert
  74. 712 IF XK=24 THEN GOSUB 5000:RETURN ' choose mOnO or cOlOr
  75. 714 IF XK=25 THEN GOSUB 7500:RETURN ' Print the screen to printer
  76. 716 IF XK=38 THEN GOSUB 3000:RETURN ' Load file
  77. 718 IF XK=30 THEN GOSUB 4800:RETURN ' print ASCII memory
  78. 720 IF XK=31 THEN GOSUB 3400:RETURN ' Save file
  79. 722 IF XK=32 THEN GOSUB 4650:RETURN ' change Direction
  80. 724 IF XK=33 THEN GOSUB 4000 :RETURN ' set Foreground color
  81. 726 IF XK=35 THEN GOSUB 4500:RETURN ' High intensity
  82. 728 IF XK=34 THEN GOSUB 4600:RETURN ' flashinG
  83. 730 IF XK=44 THEN GOSUB 1000:RETURN ' mark block Z
  84. 732 IF XK=45 THEN CUT=-1:GOSUB 1100:RETURN ' cut X
  85. 734 IF XK=46 THEN CUT=0:GOSUB 1100:RETURN ' copy C
  86. 736 IF XK=47 THEN GOSUB 1200:RETURN ' paste (V)
  87. 738 IF XK=48 THEN GOSUB 4100:RETURN 'set Background color
  88. 740 IF XK=49 THEN GOSUB 4300:RETURN ' Normal text
  89. 742 IF XK=50 THEN GOSUB 4700:RETURN ' set ASCII Memory
  90. 744 BEEP:RETURN
  91. 800 ' function keys
  92. 811 IF XK=59 THEN K$=CHR$(218):GOSUB 400:RETURN
  93. 812 IF XK=60 THEN K$=CHR$(191):GOSUB 400:RETURN
  94. 813 IF XK=61 THEN K$=CHR$(192):GOSUB 400:RETURN
  95. 814 IF XK=62 THEN K$=CHR$(217):GOSUB 400:RETURN
  96. 815 IF XK=63 THEN K$=CHR$(195):GOSUB 400:RETURN
  97. 816 IF XK=64 THEN K$=CHR$(180):GOSUB 400:RETURN
  98. 817 IF XK=65 THEN K$=CHR$(194):GOSUB 400:RETURN
  99. 818 IF XK=66 THEN K$=CHR$(193):GOSUB 400:RETURN
  100. 819 IF XK=67 THEN K$=CHR$(179):GOSUB 400:RETURN
  101. 820 IF XK=68 THEN K$=CHR$(196):GOSUB 400:RETURN
  102. 821 IF XK=104 THEN K$=CHR$(201):GOSUB 400:RETURN
  103. 822 IF XK=105 THEN K$=CHR$(187):GOSUB 400:RETURN
  104. 823 IF XK=106 THEN K$=CHR$(200):GOSUB 400:RETURN
  105. 824 IF XK=107 THEN K$=CHR$(188):GOSUB 400:RETURN
  106. 825 IF XK=108 THEN K$=CHR$(204):GOSUB 400:RETURN
  107. 826 IF XK=109 THEN K$=CHR$(185):GOSUB 400:RETURN
  108. 827 IF XK=110 THEN K$=CHR$(203):GOSUB 400:RETURN
  109. 828 IF XK=111 THEN K$=CHR$(202):GOSUB 400:RETURN
  110. 829 IF XK=112 THEN K$=CHR$(186):GOSUB 400:RETURN
  111. 830 IF XK=113 THEN K$=CHR$(205):GOSUB 400:RETURN
  112. 831 IF XK=84 THEN K$=CHR$(214):GOSUB 400:RETURN
  113. 832 IF XK=85 THEN K$=CHR$(183):GOSUB 400:RETURN
  114. 833 IF XK=86 THEN K$=CHR$(211):GOSUB 400:RETURN
  115. 834 IF XK=87 THEN K$=CHR$(189):GOSUB 400:RETURN
  116. 835 IF XK=88 THEN K$=CHR$(199):GOSUB 400:RETURN
  117. 836 IF XK=89 THEN K$=CHR$(182):GOSUB 400:RETURN
  118. 837 IF XK=90 THEN K$=CHR$(210):GOSUB 400:RETURN
  119. 838 IF XK=91 THEN K$=CHR$(208):GOSUB 400:RETURN
  120. 839 IF XK=92 THEN K$=CHR$(197):GOSUB 400:RETURN
  121. 840 IF XK=93 THEN K$=CHR$(215):GOSUB 400:RETURN
  122. 841 IF XK=94 THEN K$=CHR$(213):GOSUB 400:RETURN
  123. 842 IF XK=95 THEN K$=CHR$(184):GOSUB 400:RETURN
  124. 843 IF XK=96 THEN K$=CHR$(212):GOSUB 400:RETURN
  125. 844 IF XK=97 THEN K$=CHR$(190):GOSUB 400:RETURN
  126. 845 IF XK=98 THEN K$=CHR$(198):GOSUB 400:RETURN
  127. 846 IF XK=99 THEN K$=CHR$(181):GOSUB 400:RETURN
  128. 847 IF XK=100 THEN K$=CHR$(209):GOSUB 400:RETURN
  129. 848 IF XK=101 THEN K$=CHR$(207):GOSUB 400:RETURN
  130. 849 IF XK=102 THEN K$=CHR$(206):GOSUB 400:RETURN
  131. 850 IF XK=103 THEN K$=CHR$(216):GOSUB 400:RETURN
  132. 895 BEEP:RETURN
  133. 900 ' Alt + number keys
  134. 901 IF XK=120 THEN K$=CHR$(221):GOSUB 400:RETURN
  135. 902 IF XK=121 THEN K$=CHR$(222):GOSUB 400:RETURN
  136. 903 IF XK=122 THEN K$=CHR$(223):GOSUB 400:RETURN
  137. 904 IF XK=123 THEN K$=CHR$(220):GOSUB 400:RETURN
  138. 905 IF XK=124 THEN K$=CHR$(219):GOSUB 400:RETURN
  139. 995 BEEP:RETURN
  140. 1000 ' mark block
  141. 1005 IF MARKED THEN POKE B1M,B1K:POKE B1M+1,B1A
  142. 1010 B1M=FNLOCA(R,C):B1K=PEEK(B1M):B1A=PEEK(B1M+1):B1R=R:B1C=C
  143. 1015 POKE B1M,ASC(MARK$):POKE B1M+1,FNATTR(DBG,DFG):MARKED=-1:RETURN
  144. 1100 ' cut or copy a block
  145. 1105 MARKED=0
  146. 1110 B2M=FNLOCA(R,C):B2K=PEEK(B2M):B2A=PEEK(B2M+1):B2R=R:B2C=C
  147. 1115 POKE B2M+1,FNATTR(DBG,DFG):IF CUT THEN POKE B2M,ASC(CUT$) ELSE POKE B2M,ASC(COPY$)
  148. 1120 IF B1R>B2R THEN SWAP B1R,B2R:SWAP B1C,B2C ELSE IF B1R=B2R AND B1C>B2C THEN SWAP B1C,B2C
  149. 1125 ' cut/copy block
  150. 1130 DATTR=FNATTR(FG,BG)
  151. 1135 FOR I=B1R TO B2R:FOR J=B1C TO B2C
  152. 1140 LOCA=FNLOCA(I,J):BK(LOCA)=PEEK(LOCA):BK(LOCA+1)=PEEK(LOCA+1)
  153. 1145 IF CUT THEN POKE LOCA,32:POKE LOCA+1,DATTR
  154. 1150 NEXT J:NEXT I
  155. 1155 ' restore screen chars
  156. 1160 BK(B1M)=B1K:BK(B1M+1)=B1A
  157. 1165 BK(B2M)=B2K:BK(B2M+1)=B2A
  158. 1170 IF CUT THEN 1185
  159. 1175 POKE B1M,B1K:POKE B1M+1,B1A
  160. 1180 POKE B2M,B2K:POKE B2M+1,B2A
  161. 1185 R=B1R:C=B1C:RETURN
  162. 1200 ' paste block
  163. 1205 RR=R:CC=C
  164. 1210 IF (B2R-B1R+1>25-R+1) OR (B2C-B1C+1>80-C+1) THEN MSG$="Block too big to paste there":GOSUB 2300:GOSUB 2500:GOSUB 2700:RETURN
  165. 1215 FOR I=B1R TO B2R:FOR J=B1C TO B2C
  166. 1220 PASTELOCA=FNLOCA(R,C):BLOCKLOCA=FNLOCA(I,J):POKE PASTELOCA,BK(BLOCKLOCA):POKE PASTELOCA+1,BK(BLOCKLOCA+1)
  167. 1225 C=C+1:NEXT J:R=R+1:C=CC:NEXT I
  168. 1230 R=RR:C=CC:RETURN
  169. 2000 ' check for proper cursor position
  170. 2005 IF C>80 THEN C=1:R=R+1
  171. 2010 IF C<1 THEN C=80:R=R-1
  172. 2015 IF R>25 THEN R=1
  173. 2020 IF R<1 THEN R=25
  174. 2025 RETURN
  175. 2200 ' message routines
  176. 2300 SOUND 2000,1
  177. 2400 M=LEN(MSG$):FOR I=0 TO 2*M-1:LIN1(I)=PEEK(I):NEXT
  178. 2410 LOCATE 1,1:COLOR DBG,DFG:PRINT MSG$;:RETURN
  179. 2500 SOUND 32767,DELAY:SOUND 32767,1:RETURN ' delay
  180. 2600 FOR I=2*M TO 159:LIN1(I)=PEEK(I):NEXT
  181. 2610 LOCATE 1,M+1:PRINT SPACE$(78-M);:LOCATE 1,M+1:M=78:RETURN 'blank space for input q$
  182. 2700 FOR I=0 TO 2*M-1:POKE I,LIN1(I):NEXT:RETURN ' restore chars
  183. 3000 ' load Binary file
  184. 3005 MSG$="Load Binary file:":GOSUB 2300:GOSUB 2600:GOSUB 6000
  185. 3010 IF Q$="" THEN 3300
  186. 3015 IF LEFT$(Q$,1)="?" THEN GOSUB 8900:GOTO 3000
  187. 3020 GOSUB 3500:INFIL$=Q$
  188. 3025 BLOAD INFIL$,0
  189. 3030 SHOWFIL=0:RETURN
  190. 3200 ' load Text (ASCII) file
  191. 3205 MSG$="Load Text file:":GOSUB 23